home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / clisp-c.zoo / defs2.lsp < prev    next >
Encoding:
Text File  |  1993-06-05  |  23.9 KB  |  444 lines
  1. ;;; CLtL2-kompatible Definitionen
  2. ;;; Bruno Haible 20.5.1993
  3.  
  4. ; List of X3J13 votes and their current status in CLISP
  5. ;
  6. ; Number: from CLtL2, Index of X3J13 Votes.
  7. ; Status: indicates whether CLISP supports code that makes use of this vote.
  8. ;
  9. ; Number Title                               Status          Files affected
  10. ;
  11. ;   <1>  ADJUST-ARRAY displacement           yes             array.d
  12. ;   <2>  ADJUST-ARRAY :FILL-POINTER          yes             array.d
  13. ;   <3>  ADJUST-ARRAY not adjustable         no              array.d
  14. ;   <4>  allow local INLINE                  yes             compiler.lsp, init.lsp
  15. ;   <5>  APPLYHOOK environment               yes             eval.d
  16. ;   <6>  AREF 1D                             no              array.d
  17. ;   <7>  arguments underspecified            yes
  18. ;   <8>  array type/element type semantics   yes for arrays  type.lsp
  19. ;                                            no for complex numbers
  20. ;   <9>  ASSOC/RASSOC-IF :KEY                yes             list.d
  21. ;  <10>  *BREAK-ON-WARNINGS* obsolete        no              user1.lsp
  22. ;  <11>  character proposal                  no
  23. ;  <12>  CLOS                                no
  24. ;  <13>  CLOS macro compilation              no
  25. ;  <14>  CLOSE constructed stream            yes             stream.d
  26. ;  <15>  closed stream operations            yes             stream.d
  27. ;  <16>  colon-number                        yes             io.d
  28. ;  <17>  COMMON type                         no              predtype.d, type.lsp
  29. ;  <18>  COMPILE argument problems           yes             compiler.lsp
  30. ;  <19>  compile environment consistency     yes             compiler.lsp
  31. ;  <20>  COMPILE-FILE handling of top-level forms
  32. ;                                            yes             compiler.lsp
  33. ;  <21>  COMPILE-FILE & *PACKAGE*            yes             compiler.lsp
  34. ;  <22>  COMPILE-FILE symbol handling        yes             compiler.lsp
  35. ;  <23>  COMPILED-FUNCTION requirements      yes             compiler.lsp
  36. ;  <24>  compiler diagnostics                no              compiler.lsp
  37. ;  <25>  COMPILER-LET confusion              no              control.d, init.lsp, compiler.lsp
  38. ;  <26>  compiler verbosity                  no              compiler.lsp
  39. ;  <27>  compiler warning stream             yes             compiler.lsp
  40. ;  <28>  complex ATAN branch cut             yes             comptran.d
  41. ;  <28a> complex ATANH branch cut            yes             comptran.d
  42. ;  <29>  (COMPLEX RATIONAL) result           yes             compelem.d, comptran.d
  43. ;  <30>  condition system                    no              user1.lsp
  44. ;  <31>  condition restarts                  no              user1.lsp
  45. ;  <32>  constant circular compilation       yes             compiler.lsp
  46. ;  <33>  constant collapsing                 yes             compiler.lsp
  47. ;  <34>  constant compilable types           no for packages
  48. ;                                            yes for anything else
  49. ;  <35>  constant function compilation       yes
  50. ;  <36>  constant modification               yes
  51. ;  <37>  contagion on numerical comparisons  yes             realelem.d, flo_rest.d
  52. ;  <38>  COPY-SYMBOL copy plist              yes             defs1.lsp
  53. ;  <39>  COPY-SYMBOL print name              yes             defs1.lsp, package.d
  54. ;  <40>  data I/O                            no              io.d
  55. ;  <41>  data types hierarchy unspecified    yes             lispbibl.d
  56. ;  <42>  declaration scope                   no
  57. ;  <43>  declare array type & element references
  58. ;                                            yes
  59. ;  <44>  declare function ambiguity          yes
  60. ;  <45>  declare macros                      no              eval.d, compiler.lsp
  61. ;  <46>  declare type free                   yes
  62. ;  <47>  DECODE-UNIVERSAL-TIME daylight      yes             defs1.lsp
  63. ;  <48>  DEFCONSTANT special                 yes             control.d, compiler.lsp
  64. ;  <49>  DEFINE-COMPILER-MACRO               no              defs2.lsp
  65. ;  <50>  defining macros non top-level       no
  66. ;  <51>  DEFMACRO lambda-list                yes             defmacro.lsp
  67. ;  <52>  DEFPACKAGE                          yes             defs2.lsp
  68. ;  <53>  DEFSTRUCT constructor/key mixture   no              defstruc.lsp
  69. ;  <54>  DEFSTRUCT default value evaluation  yes             defstruc.lsp
  70. ;  <55>  DEFSTRUCT :PRINT-FUNCTION inheritance
  71. ;                                            no              defstruc.lsp
  72. ;  <56>  DEFSTRUCT redefinition              yes             defstruc.lsp
  73. ;  <57>  DEFSTRUCT slots constraints: name   no              defstruc.lsp
  74. ;  <58>  DEFSTRUCT slots constraints: number yes             defstruc.lsp
  75. ;  <59>  DEFVAR documentation                yes             macros1.lsp
  76. ;  <60>  DEFVAR init time                    yes             macros1.lsp
  77. ;  <61>  DEFVAR initialization               yes             macros1.lsp
  78. ;  <62>  DESCRIBE interactive                yes             user2.lsp
  79. ;  <63>  DESCRIBE underspecified             no              user2.lsp, clos.lsp
  80. ;  <64>  DESTRUCTURING-BIND                  no              defmacro.lsp
  81. ;  <65>  DISASSEMBLE side effect             yes             compiler.lsp
  82. ;  <66>  DO-SYMBOLS duplicates               yes             defs1.lsp, package.d
  83. ;  <67>  dotted macro forms                  yes
  84. ;  <68>  DRIBBLE technique                   yes             user2.lsp
  85. ;  <69>  DYNAMIC-EXTENT                      no
  86. ;  <70>  DYNAMIC-EXTENT & function           no
  87. ;  <71>  EQUAL & structure                   yes for EQUAL   predtype.d
  88. ;                                            no for EQUALP
  89. ;  <72>  EVAL other                          no              eval.d, compiler.lsp
  90. ;  <73>  EVAL-WHEN non top-level             no              control.d, init.lsp, compiler.lsp
  91. ;  <74>  exit extent                         yes
  92. ;  <75>  EXPT & ratio                        yes             comptran.d
  93. ;  <76>  FIXNUM non-portable                 no              array.d
  94. ;  <77>  FLET declarations                   no
  95. ;  <78>  FLET implicit block                 no
  96. ;  <79>  float underflow                     no
  97. ;  <80>  FORMAT atsign & colon               yes             format.lsp
  98. ;  <81>  FORMAT colon uparrow scope          no              format.lsp
  99. ;  <82>  FORMAT comma-interval               no              format.lsp
  100. ;  <83>  FORMAT ~E exponent-sign             yes             format.lsp
  101. ;  <84>  FORMAT op C                         no              format.lsp
  102. ;  <85>  FORMAT & pretty print               yes             format.lsp
  103. ;                                            no: ~E, ~F, ~G, ~$ also bind *PRINT-BASE* to 10 and *PRINT-RADIX* to NIL
  104. ;  <86>  function call & evaluation order    yes
  105. ;  <87>  function composition                no              defs2.lsp
  106. ;  <88>  function definition                 yes             defs2.lsp
  107. ;  <89>  function name                       no
  108. ;  <90>  FUNCTION type                       no              predtype.d, type.lsp, compiler.lsp
  109. ;  <91>  FUNCTION type: argument type semantics
  110. ;                                            yes
  111. ;  <92>  FUNCTION type: &KEY name            yes
  112. ;  <93>  FUNCTION type: &REST list element   yes
  113. ;  <94>  GENSYM name stickiness              no              symbol.d
  114. ;  <95>  GET-MACRO-CHARACTER readtable       no              io.d
  115. ;  <96>  GET-SETF-METHOD environment         yes             places.lsp
  116. ;  <97>  hash-table access                   no              hashtabl.d
  117. ;  <98>  hash-table & package generators     no              hashtabl.d, package.d, defs2.lsp
  118. ;  <99>  hash-table size                     yes             hashtabl.d
  119. ; <100>  hash-table tests                    no              hashtabl.d
  120. ; <101>  IEEE & ATAN branch cut              yes
  121. ; <102>  IMPORT & SETF SYMBOL-PACKAGE        no              package.d
  122. ; <103>  IN-PACKAGE functionality            no              package.d, compiler.lsp
  123. ; <104>  in syntax                           yes             init.lsp, compiler.lsp
  124. ; <105>  keyword argument name package       no
  125. ; <106>  LAST n                              no              list.d
  126. ; <107>  LCM no arguments                    yes             lisparit.d
  127. ; <108>  LISP package name                   no
  128. ; <109>  LISP symbol redefinition            yes
  129. ; <110>  LOAD & objects                      no
  130. ; <111>  LOAD-TIME-VALUE                     yes             control.d, init.lsp, compiler.lsp
  131. ; <112>  *LOAD-TRUENAME*                     no              init.lsp
  132. ; <113>  LOCALLY top level                   no              control.d, init.lsp, compiler.lsp
  133. ; <114>  LOOP AND discrepancy                no              loop.lsp
  134. ; <115>  LOOP facility                       no              loop.lsp
  135. ; <116>  macro caching                       yes
  136. ; <117>  macro environment extent            yes
  137. ; <118>  MACRO-FUNCTION environment          no              control.d, compiler.lsp
  138. ; <119>  MAKE-PACKAGE :USE default           yes
  139. ; <120>  MAP-INTO                            no              sequence.d
  140. ; <121>  mapping & destructive: interaction  yes             sequence.d, list.d, hashtabl.d, package.d
  141. ; <122>  more character proposal             no              charstrg.d, stream.d
  142. ; <123>  NTH-VALUE                           yes             defs2.lsp
  143. ; <124>  OPTIMIZE DEBUG info                 no              init.lsp
  144. ; <125>  package clutter                     no              init.lsp
  145. ; <126>  package deletion                    no              package.d
  146. ; <127>  package function consistency        no              package.d
  147. ; <128>  pathname: component case            no              pathname.d
  148. ; <129>  pathname: component value           no              pathname.d
  149. ; <130>  pathname: logical                   no              pathname.d
  150. ; <131>  pathname: print & read              no              io.d
  151. ; <132>  pathname: stream                    no              pathname.d, stream.d
  152. ; <133>  pathname: subdirectory list         no              pathname.d
  153. ; <134>  pathname: symbol                    no              pathname.d, stream.d
  154. ; <135>  pathname: syntax error time         yes             pathname.d
  155. ; <136>  pathname: unspecific component      no              pathname.d
  156. ; <137>  pathname: :WILD                     no              pathname.d
  157. ; <138>  PEEK-CHAR, READ-CHAR & echo         no              io.d, stream.d
  158. ; <139>  pretty-print interface              no              xp.lsp
  159. ; <140>  PRINC character                     yes             io.d
  160. ; <141>  *PRINT-CASE* / *PRINT-ESCAPE* interaction
  161. ;                                            no              io.d
  162. ; <142>  *PRINT-CIRCLE* shared               yes             io.d
  163. ; <143>  *PRINT-CIRCLE* structure            yes             io.d
  164. ; <144>  PROCLAIM etc. in COMPILE-FILE       no              defs2.lsp
  165. ; <145>  PROCLAIM INLINE: where              yes             compiler.lsp
  166. ; <146>  PUSH & evaluation order             yes             places.lsp
  167. ; <147>  QUOTE semantics                     yes
  168. ; <148>  range of :COUNT keyword             no              sequence.d
  169. ; <149>  range of start and end parameters   no for SUBSEQ   sequence.d
  170. ;                                            yes for anything else
  171. ; <150>  READ: case sensitivity              no              io.d
  172. ; <151>  REAL number type                    yes             predtype.d, type.lsp
  173. ; <152>  REDUCE argument extraction          no              sequence.d
  174. ; <153>  REMF & destruction: unspecified     no for NRECONC  list.d
  175. ;                                            yes for anything else
  176. ; <154>  REQUIRE pathname defaults           no              defs1.lsp
  177. ; <155>  &REST list allocation               yes             eval.d
  178. ; <156>  return values unspecified           yes             macros1.lsp, package.d, io.d
  179. ; <157>  ROOM :DEFAULT argument              no              debug.d
  180. ; <158>  sequence type & length              no              sequence.d, predtype.d
  181. ; <159>  SETF & multiple store variables     yes for SETF    places.lsp
  182. ;                                            no for SHIFTF, ROTATEF, ASSERT
  183. ; <160>  SETF & sub-methods                  yes             places.lsp
  184. ; <161>  SHADOW: already present             yes             package.d
  185. ; <162>  sharp-comma confusion               no              io.d
  186. ; <163>  sharpsign-plus/minus package        no              io.d, spvw.d, init.lsp, compiler.lsp
  187. ; <164>  special type-shadowing              yes
  188. ; <165>  *STANDARD-INPUT* initial binding    yes             stream.d
  189. ; <166>  STEP environment                    yes             user1.lsp, macros2.lsp
  190. ; <167>  stream access                       no              stream.d
  191. ; <168>  stream capabilities                 yes             stream.d
  192. ; <169>  string coercion                     yes             charstrg.d
  193. ; <170>  SUBSEQ out of bounds                yes             sequence.d
  194. ; <171>  SUBTYPEP too vague                  yes             type.lsp
  195. ; <172>  SYMBOL-MACROLET & DECLARE           no
  196. ; <173>  SYMBOL-MACROLET semantics           no
  197. ; <174>  syntactic environment access        no
  198. ; <175>  TAILP & NIL                         no              list.d
  199. ; <176>  :TEST-NOT, -IF-NOT                  no              sequence.d, list.d
  200. ; <177>  THE ambiguity                       yes
  201. ; <178>  time-zone non-integer               yes             defs1.lsp
  202. ; <179>  TYPE-OF underconstrained            yes             predtype.d
  203. ; <180>  undefined variables and functions   yes
  204. ; <181>  UNREAD-CHAR after PEEK-CHAR         yes             stream.d
  205. ; <182>  variable list asymmetry             yes             macros1.lsp
  206. ; <183>  WITH-COMPILATION-UNIT               no              compiler.lsp
  207. ; <184>  WITH-OPEN-FILE & does-not-exist     yes             macros2.lsp
  208. ; <185>  WITH-OUTPUT-TO-STRING append style  yes             macros2.lsp
  209. ; <186>  ZLOS conditions                     no              user1.lsp
  210.  
  211. ;===============================================================================
  212.  
  213. (in-package "LISP")
  214. (export '(nth-value function-lambda-expression defpackage))
  215. (in-package "SYSTEM")
  216.  
  217. ;-------------------------------------------------------------------------------
  218.  
  219. ;; Macro (nth-value n form) == (nth n (multiple-value-list form)), CLtL2 S. 184
  220. (defmacro nth-value (n form)
  221.   (if (and (integerp n) (>= n 0))
  222.     (if (< n (1- multiple-values-limit))
  223.       (if (= n 0)
  224.         `(PROG1 ,form)
  225.         (let ((resultvar (gensym)))
  226.           (do ((vars (list resultvar))
  227.                (ignores nil)
  228.                (i n (1- i)))
  229.               ((zerop i)
  230.                `(MULTIPLE-VALUE-BIND ,vars ,form
  231.                   (DECLARE (IGNORE ,@ignores))
  232.                   ,resultvar
  233.               ) )
  234.             (let ((g (gensym))) (push g vars) (push g ignores))
  235.       ) ) )
  236.       `(PROGN ,form NIL)
  237.     )
  238.     `(NTH ,n (MULTIPLE-VALUE-LIST ,form))
  239. ) )
  240.  
  241. ;-------------------------------------------------------------------------------
  242.  
  243. ;; Interpretierte Funktion in Lambda-Ausdruck umwandeln, CLtL2 S. 682
  244. (defun function-lambda-expression (obj)
  245.   (unless (sys::closurep obj)
  246.     (error #+DEUTSCH "~: ~ ist keine Funktion."
  247.            #+ENGLISH "~: ~ is not a function"
  248.            'function-lambda-expression obj
  249.   ) )
  250.   (if (not (compiled-function-p obj))
  251.     (values (cons 'LAMBDA (sys::%record-ref obj 1)) ; Lambda-Ausdruck ohne Docstring
  252.             (vector ; Environment
  253.                     (sys::%record-ref obj 4) ; venv
  254.                     (sys::%record-ref obj 5) ; fenv
  255.                     (sys::%record-ref obj 6) ; benv
  256.                     (sys::%record-ref obj 7) ; genv
  257.                     (sys::%record-ref obj 8) ; denv
  258.             )
  259.             (sys::%record-ref obj 0) ; Name
  260.     )
  261.     (values nil t nil)
  262. ) )
  263.  
  264. ;-------------------------------------------------------------------------------
  265.  
  266. ;; Package-Definition und -Installation, CLtL2 S. 270
  267. (defmacro defpackage (packname &rest options)
  268.   (flet ((check-packname (name)
  269.            (cond ((stringp name) name)
  270.                  ((symbolp name) (symbol-name name))
  271.                  (t (error #+DEUTSCH "~S: Package-Name muß ein String oder Symbol sein, nicht ~S."
  272.                            #+ENGLISH "~S: package name ~S should be a string or a symbol"
  273.                            #+FRANCAIS "~S : Le nom d'un paquetage doit être une chaîne ou un symbole et non ~S."
  274.                            'defpackage name
  275.          ) )     )  )
  276.          (check-symname (name)
  277.            (cond ((stringp name) name)
  278.                  ((symbolp name) (symbol-name name))
  279.                  (t (error #+DEUTSCH "~S ~A: Symbol-Name muß ein String oder Symbol sein, nicht ~S."
  280.                            #+ENGLISH "~S ~A: symbol name ~S should be a string or a symbol"
  281.                            #+FRANCAIS "~S ~A : Le nom d'un symbole doit être une chaîne ou un symbole et non ~S."
  282.                            'defpackage packname name
  283.         )) )     )  )
  284.     (setq packname (check-packname packname))
  285.     ; Optionen abarbeiten:
  286.     (let ((size nil) ; Flag ob :SIZE schon da war
  287.           (nickname-list '()) ; Liste von Nicknames
  288.           (shadow-list '()) ; Liste von Symbolnamen für shadow
  289.           (shadowing-list '()) ; Listen von Paaren (Symbolname . Paketname) für shadowing-import
  290.           (use-list '()) ; Liste von Paketnamen für use-package
  291.           (use-default '("LISP")) ; Default-Wert für use-list
  292.           (import-list '()) ; Listen von Paaren (Symbolname . Paketname) für import
  293.           (intern-list '()) ; Liste von Symbolnamen für intern
  294.           (symname-list '()) ; Liste aller bisher aufgeführten Symbolnamen
  295.           (export-list '())) ; Liste von Symbolnamen für export
  296.       (flet ((record-symname (name)
  297.                (if (member name symname-list :test #'string=)
  298.                  (error #+DEUTSCH "~S ~A: Symbol ~A darf nur einmal aufgeführt werden."
  299.                         #+ENGLISH "~S ~A: the symbol ~A must not be specified more than once"
  300.                         #+FRANCAIS "~S ~A : Le symbole ~A ne peut être mentionné qu'une seule fois."
  301.                         'defpackage packname name
  302.                  )
  303.                  (push name symname-list)
  304.                )
  305.                name
  306.             ))
  307.         (dolist (option options)
  308.           (if (listp option)
  309.             (if (keywordp (car option))
  310.               (case (first option)
  311.                 (:SIZE
  312.                   (if size
  313.                     (error #+DEUTSCH "~S ~A: Die Option ~S darf nur einmal angegeben werden."
  314.                            #+ENGLISH "~S ~A: the ~S option must not be given more than once"
  315.                            #+FRANCAIS "~S ~A : L'option ~S ne doit apparaître qu'une seule fois."
  316.                            'defpackage packname ':SIZE
  317.                     )
  318.                     (setq size t) ; Argument wird ignoriert
  319.                 ) )
  320.                 (:NICKNAMES
  321.                   (dolist (name (rest option))
  322.                     (push (check-packname name) nickname-list)
  323.                 ) )
  324.                 (:SHADOW
  325.                   (dolist (name (rest option))
  326.                     (push (record-symname (check-symname name)) shadow-list)
  327.                 ) )
  328.                 (:SHADOWING-IMPORT-FROM
  329.                   (let ((pack (check-packname (second option))))
  330.                     (dolist (name (cddr option))
  331.                       (push (cons (record-symname (check-symname name)) pack)
  332.                             shadowing-list
  333.                 ) ) ) )
  334.                 (:USE
  335.                   (dolist (name (rest option))
  336.                     (push (check-packname name) use-list)
  337.                   )
  338.                   (setq use-default nil)
  339.                 )
  340.                 (:IMPORT-FROM
  341.                   (let ((pack (check-packname (second option))))
  342.                     (dolist (name (cddr option))
  343.                       (push (cons (record-symname (check-symname name)) pack)
  344.                             import-list
  345.                 ) ) ) )
  346.                 (:INTERN
  347.                   (dolist (name (rest option))
  348.                     (push (record-symname (check-symname name)) intern-list)
  349.                 ) )
  350.                 (:EXPORT
  351.                   (dolist (name (rest option))
  352.                     (push (check-symname name) export-list)
  353.                 ) )
  354.                 (T (error #+DEUTSCH "~S ~A: Die Option ~S gibt es nicht."
  355.                           #+ENGLISH "~S ~A: unknown option ~S"
  356.                           #+FRANCAIS "~S ~A : Option ~S non reconnue."
  357.                           'defpackage packname (first option)
  358.               ) )  )
  359.               (error #+DEUTSCH "~S ~A: Falsche Syntax in ~S-Option: ~S"
  360.                      #+ENGLISH "~S ~A: invalid syntax in ~S option: ~S"
  361.                      #+FRANCAIS "~S ~A : Mauvaise syntaxe dans l'option ~S: ~S"
  362.                      'defpackage packname 'defpackage option
  363.             ) )
  364.             (error #+DEUTSCH "~S ~A: Das ist keine ~S-Option: ~S"
  365.                    #+ENGLISH "~S ~A: not a ~S option: ~S"
  366.                    #+FRANCAIS "~S ~A : Ceci n'est pas une option ~S: ~S"
  367.                    'defpackage packname 'defpackage option
  368.         ) ) )
  369.         ; Auf Überschneidungen zwischen intern-list und export-list prüfen:
  370.         (setq symname-list intern-list)
  371.         (mapc #'record-symname export-list)
  372.       )
  373.       ; Listen umdrehen und Default-Werte eintragen:
  374.       (setq nickname-list (nreverse nickname-list))
  375.       (setq shadow-list (nreverse shadow-list))
  376.       (setq shadowing-list (nreverse shadowing-list))
  377.       (setq use-list (or use-default (nreverse use-list)))
  378.       (setq import-list (nreverse import-list))
  379.       (setq intern-list (nreverse intern-list))
  380.       (setq export-list (nreverse export-list))
  381.       ; Expansion produzieren:
  382.       `(EVAL-WHEN (LOAD COMPILE EVAL)
  383.          (IN-PACKAGE ,packname :NICKNAMES ',nickname-list)
  384.          ; Schritt 1
  385.          ,@(if shadow-list
  386.              `((SHADOW ',(mapcar #'make-symbol shadow-list) ,packname))
  387.            )
  388.          ,@(mapcar
  389.              #'(lambda (pair)
  390.                  `(SHADOWING-IMPORT-CERROR ,(car pair) ,(cdr pair) ,packname)
  391.                )
  392.              shadowing-list
  393.            )
  394.          ; Schritt 2
  395.          ,@(if use-list `((USE-PACKAGE ',use-list ,packname)))
  396.          ; Schritt 3
  397.          ,@(mapcar
  398.              #'(lambda (pair)
  399.                  `(IMPORT-CERROR ,(car pair) ,(cdr pair) ,packname)
  400.                )
  401.              import-list
  402.            )
  403.          ,@(if intern-list
  404.              `((MAPCAR #'INTERN ',(mapcar #'car intern-list) ',(mapcar #'cdr intern-list)))
  405.            )
  406.          ; Schritt 4
  407.          ,@(if export-list
  408.              `((INTERN-EXPORT ',export-list ,packname))
  409.            )
  410.          (FIND-PACKAGE ,packname)
  411.        )
  412. ) ) )
  413. ; Hilfsfunktionen:
  414. (defun find-symbol-cerror (string packname calling-packname)
  415.   (multiple-value-bind (sym found) (find-symbol string packname)
  416.     (unless found
  417.       (cerror #+DEUTSCH "Dieses Symbol wird erzeugt."
  418.               #+ENGLISH "This symbol will be created."
  419.               #+FRANCAIS "Ce symbole sera créé."
  420.               #+DEUTSCH "~S ~A: Es gibt kein Symbol ~A::~A ."
  421.               #+ENGLISH "~S ~A: There is no symbol ~A::~A ."
  422.               #+FRANCAIS "~S ~A : Il n'y a pas de symbole ~A::~A ."
  423.               'defpackage calling-packname packname string
  424.       )
  425.       (setq sym (intern string packname))
  426.     )
  427.     sym
  428. ) )
  429. (defun shadowing-import-cerror (string packname calling-packname)
  430.   (shadowing-import (find-symbol-cerror string packname calling-packname)
  431.                     calling-packname
  432. ) )
  433. (defun import-cerror (string packname calling-packname)
  434.   (import (find-symbol-cerror string packname calling-packname)
  435.           calling-packname
  436. ) )
  437. (defun intern-export (string-list packname)
  438.   (export (mapcar #'(lambda (string) (intern string packname)) string-list)
  439.           packname
  440. ) )
  441.  
  442. ;-------------------------------------------------------------------------------
  443.  
  444.